home *** CD-ROM | disk | FTP | other *** search
/ Cream of the Crop 26 / Cream of the Crop 26.iso / os2 / octa209s.zip / octave-2.09 / libs / f2c / src / data.c < prev    next >
C/C++ Source or Header  |  1994-05-06  |  10KB  |  476 lines
  1. /****************************************************************
  2. Copyright 1990, 1993, 1994 by AT&T Bell Laboratories and Bellcore.
  3.  
  4. Permission to use, copy, modify, and distribute this software
  5. and its documentation for any purpose and without fee is hereby
  6. granted, provided that the above copyright notice appear in all
  7. copies and that both that the copyright notice and this
  8. permission notice and warranty disclaimer appear in supporting
  9. documentation, and that the names of AT&T Bell Laboratories or
  10. Bellcore or any of their entities not be used in advertising or
  11. publicity pertaining to distribution of the software without
  12. specific, written prior permission.
  13.  
  14. AT&T and Bellcore disclaim all warranties with regard to this
  15. software, including all implied warranties of merchantability
  16. and fitness.  In no event shall AT&T or Bellcore be liable for
  17. any special, indirect or consequential damages or any damages
  18. whatsoever resulting from loss of use, data or profits, whether
  19. in an action of contract, negligence or other tortious action,
  20. arising out of or in connection with the use or performance of
  21. this software.
  22. ****************************************************************/
  23.  
  24. #include "defs.h"
  25.  
  26. /* ROUTINES CALLED DURING DATA AND PARAMETER STATEMENT PROCESSING */
  27.  
  28. static char datafmt[] = "%s\t%09ld\t%d";
  29. static char *cur_varname;
  30.  
  31. /* another initializer, called from parser */
  32.  void
  33. #ifdef KR_headers
  34. dataval(repp, valp)
  35.     register expptr repp;
  36.     register expptr valp;
  37. #else
  38. dataval(register expptr repp, register expptr valp)
  39. #endif
  40. {
  41.     int i, nrep;
  42.     ftnint elen;
  43.     register Addrp p;
  44.  
  45.     if (parstate < INDATA) {
  46.         frexpr(repp);
  47.         goto ret;
  48.         }
  49.     if(repp == NULL)
  50.         nrep = 1;
  51.     else if (ISICON(repp) && repp->constblock.Const.ci >= 0)
  52.         nrep = repp->constblock.Const.ci;
  53.     else
  54.     {
  55.         err("invalid repetition count in DATA statement");
  56.         frexpr(repp);
  57.         goto ret;
  58.     }
  59.     frexpr(repp);
  60.  
  61.     if( ! ISCONST(valp) )
  62.     {
  63.         err("non-constant initializer");
  64.         goto ret;
  65.     }
  66.  
  67.     if(toomanyinit) goto ret;
  68.     for(i = 0 ; i < nrep ; ++i)
  69.     {
  70.         p = nextdata(&elen);
  71.         if(p == NULL)
  72.         {
  73.             err("too many initializers");
  74.             toomanyinit = YES;
  75.             goto ret;
  76.         }
  77.         setdata((Addrp)p, (Constp)valp, elen);
  78.         frexpr((expptr)p);
  79.     }
  80.  
  81. ret:
  82.     frexpr(valp);
  83. }
  84.  
  85.  
  86.  Addrp
  87. #ifdef KR_headers
  88. nextdata(elenp)
  89.     ftnint *elenp;
  90. #else
  91. nextdata(ftnint *elenp)
  92. #endif
  93. {
  94.     register struct Impldoblock *ip;
  95.     struct Primblock *pp;
  96.     register Namep np;
  97.     register struct Rplblock *rp;
  98.     tagptr p;
  99.     expptr neltp;
  100.     register expptr q;
  101.     int skip;
  102.     ftnint off, vlen;
  103.  
  104.     while(curdtp)
  105.     {
  106.         p = (tagptr)curdtp->datap;
  107.         if(p->tag == TIMPLDO)
  108.         {
  109.             ip = &(p->impldoblock);
  110.             if(ip->implb==NULL || ip->impub==NULL || ip->varnp==NULL)
  111.                 fatali("bad impldoblock 0%o", (int) ip);
  112.             if(ip->isactive)
  113.                 ip->varvp->Const.ci += ip->impdiff;
  114.             else
  115.             {
  116.                 q = fixtype(cpexpr(ip->implb));
  117.                 if( ! ISICON(q) )
  118.                     goto doerr;
  119.                 ip->varvp = (Constp) q;
  120.  
  121.                 if(ip->impstep)
  122.                 {
  123.                     q = fixtype(cpexpr(ip->impstep));
  124.                     if( ! ISICON(q) )
  125.                         goto doerr;
  126.                     ip->impdiff = q->constblock.Const.ci;
  127.                     frexpr(q);
  128.                 }
  129.                 else
  130.                     ip->impdiff = 1;
  131.  
  132.                 q = fixtype(cpexpr(ip->impub));
  133.                 if(! ISICON(q))
  134.                     goto doerr;
  135.                 ip->implim = q->constblock.Const.ci;
  136.                 frexpr(q);
  137.  
  138.                 ip->isactive = YES;
  139.                 rp = ALLOC(Rplblock);
  140.                 rp->rplnextp = rpllist;
  141.                 rpllist = rp;
  142.                 rp->rplnp = ip->varnp;
  143.                 rp->rplvp = (expptr) (ip->varvp);
  144.                 rp->rpltag = TCONST;
  145.             }
  146.  
  147.             if( (ip->impdiff>0 && (ip->varvp->Const.ci <= ip->implim))
  148.                 || (ip->impdiff<0 && (ip->varvp->Const.ci >= ip->implim)) )
  149.             { /* start new loop */
  150.                 curdtp = ip->datalist;
  151.                 goto next;
  152.             }
  153.  
  154.             /* clean up loop */
  155.  
  156.             if(rpllist)
  157.             {
  158.                 rp = rpllist;
  159.                 rpllist = rpllist->rplnextp;
  160.                 free( (charptr) rp);
  161.             }
  162.             else
  163.                 Fatal("rpllist empty");
  164.  
  165.             frexpr((expptr)ip->varvp);
  166.             ip->isactive = NO;
  167.             curdtp = curdtp->nextp;
  168.             goto next;
  169.         }
  170.  
  171.         pp = (struct Primblock *) p;
  172.         np = pp->namep;
  173.         cur_varname = np->fvarname;
  174.         skip = YES;
  175.  
  176.         if(p->primblock.argsp==NULL && np->vdim!=NULL)
  177.         {   /* array initialization */
  178.             q = (expptr) mkaddr(np);
  179.             off = typesize[np->vtype] * curdtelt;
  180.             if(np->vtype == TYCHAR)
  181.                 off *= np->vleng->constblock.Const.ci;
  182.             q->addrblock.memoffset =
  183.                 mkexpr(OPPLUS, q->addrblock.memoffset, mkintcon(off) );
  184.             if( (neltp = np->vdim->nelt) && ISCONST(neltp))
  185.             {
  186.                 if(++curdtelt < neltp->constblock.Const.ci)
  187.                     skip = NO;
  188.             }
  189.             else
  190.                 err("attempt to initialize adjustable array");
  191.         }
  192.         else
  193.             q = mklhs((struct Primblock *)cpexpr((expptr)pp), 0);
  194.         if(skip)
  195.         {
  196.             curdtp = curdtp->nextp;
  197.             curdtelt = 0;
  198.         }
  199.         if(q->headblock.vtype == TYCHAR)
  200.             if(ISICON(q->headblock.vleng))
  201.                 *elenp = q->headblock.vleng->constblock.Const.ci;
  202.             else    {
  203.                 err("initialization of string of nonconstant length");
  204.                 continue;
  205.             }
  206.         else    *elenp = typesize[q->headblock.vtype];
  207.  
  208.         if (np->vstg == STGBSS) {
  209.             vlen = np->vtype==TYCHAR
  210.                 ? np->vleng->constblock.Const.ci
  211.                 : typesize[np->vtype];
  212.             if(vlen > 0)
  213.                 np->vstg = STGINIT;
  214.             }
  215.         return( (Addrp) q );
  216.  
  217. doerr:
  218.         err("nonconstant implied DO parameter");
  219.         frexpr(q);
  220.         curdtp = curdtp->nextp;
  221.  
  222. next:
  223.         curdtelt = 0;
  224.     }
  225.  
  226.     return(NULL);
  227. }
  228.  
  229.  
  230.  
  231. LOCAL FILEP dfile;
  232.  
  233.  void
  234. #ifdef KR_headers
  235. setdata(varp, valp, elen)
  236.     register Addrp varp;
  237.     register Constp valp;
  238.     ftnint elen;
  239. #else
  240. setdata(register Addrp varp, register Constp valp, ftnint elen)
  241. #endif
  242. {
  243.     struct Constblock con;
  244.     register int type;
  245.     int i, k, valtype;
  246.     ftnint offset;
  247.     char *varname;
  248.     static Addrp badvar;
  249.     register unsigned char *s;
  250.     static int last_lineno;
  251.     static char *last_varname;
  252.  
  253.     if (varp->vstg == STGCOMMON) {
  254.         if (!(dfile = blkdfile))
  255.             dfile = blkdfile = opf(blkdfname, textwrite);
  256.         }
  257.     else {
  258.         if (procclass == CLBLOCK) {
  259.             if (varp != badvar) {
  260.                 badvar = varp;
  261.                 warn1("%s is not in a COMMON block",
  262.                     varp->uname_tag == UNAM_NAME
  263.                     ? varp->user.name->fvarname
  264.                     : "???");
  265.                 }
  266.             return;
  267.             }
  268.         if (!(dfile = initfile))
  269.             dfile = initfile = opf(initfname, textwrite);
  270.         }
  271.     varname = dataname(varp->vstg, varp->memno);
  272.     offset = varp->memoffset->constblock.Const.ci;
  273.     type = varp->vtype;
  274.     valtype = valp->vtype;
  275.     if(type!=TYCHAR && valtype==TYCHAR)
  276.     {
  277.         if(! ftn66flag
  278.         && (last_varname != cur_varname || last_lineno != lineno)) {
  279.             /* prevent multiple warnings */
  280.             last_lineno = lineno;
  281.             warn1(
  282.     "non-character datum %.42s initialized with character string",
  283.                 last_varname = cur_varname);
  284.             }
  285.         varp->vleng = ICON(typesize[type]);
  286.         varp->vtype = type = TYCHAR;
  287.     }
  288.     else if( (type==TYCHAR && valtype!=TYCHAR) ||
  289.         (cktype(OPASSIGN,type,valtype) == TYERROR) )
  290.     {
  291.         err("incompatible types in initialization");
  292.         return;
  293.     }
  294.     if(type == TYADDR)
  295.         con.Const.ci = valp->Const.ci;
  296.     else if(type != TYCHAR)
  297.     {
  298.         if(valtype == TYUNKNOWN)
  299.             con.Const.ci = valp->Const.ci;
  300.         else    consconv(type, &con, valp);
  301.     }
  302.  
  303.     k = 1;
  304.  
  305.     switch(type)
  306.     {
  307.     case TYLOGICAL:
  308.         if (tylogical != TYLONG)
  309.             type = tylogical;
  310.     case TYINT1:
  311.     case TYLOGICAL1:
  312.     case TYLOGICAL2:
  313.     case TYSHORT:
  314.     case TYLONG:
  315. #ifdef TYQUAD
  316.     case TYQUAD:
  317. #endif
  318.         dataline(varname, offset, type);
  319.         prconi(dfile, con.Const.ci);
  320.         break;
  321.  
  322.     case TYADDR:
  323.         dataline(varname, offset, type);
  324.         prcona(dfile, con.Const.ci);
  325.         break;
  326.  
  327.     case TYCOMPLEX:
  328.     case TYDCOMPLEX:
  329.         k = 2;
  330.     case TYREAL:
  331.     case TYDREAL:
  332.         dataline(varname, offset, type);
  333.         prconr(dfile, &con, k);
  334.         break;
  335.  
  336.     case TYCHAR:
  337.         k = valp -> vleng -> constblock.Const.ci;
  338.         if (elen < k)
  339.             k = elen;
  340.         s = (unsigned char *)valp->Const.ccp;
  341.         for(i = 0 ; i < k ; ++i) {
  342.             dataline(varname, offset++, TYCHAR);
  343.             fprintf(dfile, "\t%d\n", *s++);
  344.             }
  345.         k = elen - valp->vleng->constblock.Const.ci;
  346.         if(k > 0) {
  347.             dataline(varname, offset, TYBLANK);
  348.             fprintf(dfile, "\t%d\n", k);
  349.             }
  350.         break;
  351.  
  352.     default:
  353.         badtype("setdata", type);
  354.     }
  355.  
  356. }
  357.  
  358.  
  359.  
  360. /*
  361.    output form of name is padded with blanks and preceded
  362.    with a storage class digit
  363. */
  364.  char*
  365. #ifdef KR_headers
  366. dataname(stg, memno)
  367.     int stg;
  368.     long memno;
  369. #else
  370. dataname(int stg, long memno)
  371. #endif
  372. {
  373.     static char varname[64];
  374.     register char *s, *t;
  375.     char buf[16];
  376.  
  377.     if (stg == STGCOMMON) {
  378.         varname[0] = '2';
  379.         sprintf(s = buf, "Q.%ld", memno);
  380.         }
  381.     else {
  382.         varname[0] = stg==STGEQUIV ? '1' : '0';
  383.         s = memname(stg, memno);
  384.         }
  385.     t = varname + 1;
  386.     while(*t++ = *s++);
  387.     *t = 0;
  388.     return(varname);
  389. }
  390.  
  391.  
  392.  
  393.  
  394.  void
  395. #ifdef KR_headers
  396. frdata(p0)
  397.     chainp p0;
  398. #else
  399. frdata(chainp p0)
  400. #endif
  401. {
  402.     register struct Chain *p;
  403.     register tagptr q;
  404.  
  405.     for(p = p0 ; p ; p = p->nextp)
  406.     {
  407.         q = (tagptr)p->datap;
  408.         if(q->tag == TIMPLDO)
  409.         {
  410.             if(q->impldoblock.isbusy)
  411.                 return;    /* circular chain completed */
  412.             q->impldoblock.isbusy = YES;
  413.             frdata(q->impldoblock.datalist);
  414.             free( (charptr) q);
  415.         }
  416.         else
  417.             frexpr(q);
  418.     }
  419.  
  420.     frchain( &p0);
  421. }
  422.  
  423.  
  424.  void
  425. #ifdef KR_headers
  426. dataline(varname, offset, type)
  427.     char *varname;
  428.     ftnint offset;
  429.     int type;
  430. #else
  431. dataline(char *varname, ftnint offset, int type)
  432. #endif
  433. {
  434.     fprintf(dfile, datafmt, varname, offset, type);
  435. }
  436.  
  437.  void
  438. #ifdef KR_headers
  439. make_param(p, e)
  440.     register struct Paramblock *p;
  441.     expptr e;
  442. #else
  443. make_param(register struct Paramblock *p, expptr e)
  444. #endif
  445. {
  446.     register expptr q;
  447.  
  448.     p->vclass = CLPARAM;
  449.     impldcl((Namep)p);
  450.     if (e->headblock.vtype != TYCHAR)
  451.         e = putx(fixtype(e));
  452.     p->paramval = q = mkconv(p->vtype, e);
  453.     if (p->vtype == TYCHAR) {
  454.         if (q->tag == TEXPR)
  455.             p->paramval = q = fixexpr((Exprp)q);
  456.         if (!ISCONST(q) || q->constblock.vtype != TYCHAR) {
  457.             errstr("invalid value for character parameter %s",
  458.                 p->fvarname);
  459.             return;
  460.             }
  461.         if (!(e = p->vleng))
  462.             p->vleng = ICON(q->constblock.vleng->constblock.Const.ci
  463.                     + q->constblock.Const.ccp1.blanks);
  464.         else if (q->constblock.vleng->constblock.Const.ci
  465.                 > e->constblock.Const.ci) {
  466.             q->constblock.vleng->constblock.Const.ci
  467.                 = e->constblock.Const.ci;
  468.             q->constblock.Const.ccp1.blanks = 0;
  469.             }
  470.         else
  471.             q->constblock.Const.ccp1.blanks
  472.                 = e->constblock.Const.ci
  473.                 - q->constblock.vleng->constblock.Const.ci;
  474.         }
  475.     }
  476.